{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}

module FRP.Taupo.Scheduled where

import Control.Fold1 (Fold1, fold1)
import Control.Selective (Selective (select))
import Data.Bifunctor (second)
import Data.Functor.Combinator (HFunctor (hmap), Inject (inject), Interpret (retract))
import Data.Functor.Identity (Identity (Identity))
import Data.Kind (Type)
import FRP.Taupo.Sync (SyncSignal)
import GHC.TypeNats (Nat, type (<=))

data ScheduledSignal (freq :: Nat) (eff :: Type -> Type) (a :: Type) where
  ScheduledSignal :: SyncSignal eff a -> ScheduledSignal freq eff a
  ScheduledBatch ::
    (1 <= freq') =>
    Fold1 a b ->
    ScheduledSignal freq' eff a ->
    ScheduledSignal freq eff b
  ScheduledFillIn ::
    (1 <= freq') =>
    (Maybe a -> b) ->
    ScheduledSignal freq' eff a ->
    ScheduledSignal freq eff b
  ScheduledEvent :: eff b -> ScheduledSignal freq eff a -> ScheduledSignal freq eff a
  ScheduledMux ::
    (a -> b -> c) ->
    ScheduledSignal freq eff a ->
    ScheduledSignal freq eff b ->
    ScheduledSignal freq eff c
  ScheduledSelect ::
    ScheduledSignal freq eff (Either a b) ->
    ScheduledSignal freq eff (a -> b) ->
    ScheduledSignal freq eff b

instance (Functor eff) => Functor (ScheduledSignal freq eff) where
  fmap f = \case
    ScheduledSignal sig -> ScheduledSignal (fmap f sig)
    ScheduledBatch fld sig -> ScheduledBatch (fmap f fld) sig
    ScheduledFillIn g sig -> ScheduledFillIn (f . g) sig
    ScheduledEvent act sig -> ScheduledEvent act (fmap f sig)
    ScheduledMux g sig1 sig2 -> ScheduledMux (\x -> f . g x) sig1 sig2
    ScheduledSelect sigData sigCtrl ->
      ScheduledSelect (fmap (second f) sigData) (fmap (f .) sigCtrl)
  (<$) x = \case
    ScheduledSignal sig -> ScheduledSignal (x <$ sig)
    ScheduledBatch fld sig -> ScheduledBatch (x <$ fld) sig
    ScheduledFillIn _ sig -> ScheduledFillIn (const x) sig
    ScheduledEvent act sig -> ScheduledEvent act (x <$ sig)
    ScheduledMux _ sig1 sig2 -> ScheduledMux (\_ _ -> x) sig1 sig2
    ScheduledSelect sigData sigCtrl ->
      ScheduledSelect (Right x <$ sigData) (const x <$ sigCtrl)

-- TODO: Applicative, Selective, Semialign, etc.

instance HFunctor (ScheduledSignal freq) where
  hmap nt = \case
    ScheduledSignal sig -> ScheduledSignal (hmap nt sig)
    ScheduledBatch fld sig -> ScheduledBatch fld (hmap nt sig)
    ScheduledEvent act sig -> ScheduledEvent (nt act) (hmap nt sig)
    ScheduledFillIn f sig -> ScheduledFillIn f (hmap nt sig)
    ScheduledMux f sig1 sig2 -> ScheduledMux f (hmap nt sig1) (hmap nt sig2)
    ScheduledSelect sigData sigCtrl -> ScheduledSelect (hmap nt sigData) (hmap nt sigCtrl)

instance (1 <= freq) => Inject (ScheduledSignal freq) where
  inject = ScheduledSignal . inject

instance (Selective eff, 1 <= freq) => Interpret (ScheduledSignal freq) eff where
  retract = \case
    ScheduledSignal act -> retract act
    ScheduledBatch fld sig -> fold1 fld . Identity <$> retract sig
    ScheduledFillIn f sig -> f . Just <$> retract sig
    ScheduledEvent act sig -> act *> retract sig
    ScheduledMux f sig1 sig2 -> f <$> retract sig1 <*> retract sig2
    ScheduledSelect sigData sigCtrl -> select (retract sigData) (retract sigCtrl)
